home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2001 June / PC-WELT 6_2001.ISO / misc / rpmtools.pm < prev    next >
Encoding:
Perl POD Document  |  2001-04-18  |  17.0 KB  |  564 lines
  1. package rpmtools;
  2.  
  3. use strict;
  4. use vars qw($VERSION @ISA);
  5.  
  6. require DynaLoader;
  7.  
  8. @ISA = qw(DynaLoader);
  9. $VERSION = '2.3';
  10.  
  11. bootstrap rpmtools $VERSION;
  12.  
  13. =head1 NAME
  14.  
  15. rpmtools - Mandrake perl tools to handle rpm files and hdlist files
  16.  
  17. =head1 SYNOPSYS
  18.  
  19.     require rpmtools;
  20.  
  21.     my $params = new rpmtools;
  22.  
  23.     $params->read_hdlists("/export/Mandrake/base/hdlist.cz",
  24.                           "/export/Mandrake/base/hdlist2.cz");
  25.     $params->read_rpms("/RPMS/rpmtools-2.1-5mdk.i586.rpm");
  26.     $params->compute_depslist();
  27.  
  28.     my $db = $params->db_open("");
  29.     $params->db_traverse_tag($db,
  30.                              "name", \@names,
  31.                              [ qw(name version release) ],
  32.                              sub {
  33.         my ($p) = @_;
  34.         print "$p->{name}-$p->{version}-$p->{release}\n";
  35.     });
  36.     $params->db_traverse($db,
  37.                          [ qw(name version release) ],
  38.                          sub {
  39.         my ($p) = @_;
  40.         print "$p->{name}-$p->{version}-$p->{release}\n";
  41.     });
  42.     $params->db_close($db);
  43.  
  44.     $params->read_depslist(\*STDIN);
  45.     $params->write_depslist(\*STDOUT);
  46.  
  47.     rpmtools::version_compare("1.0.23", "1.0.4");
  48.  
  49. =head1 DESCRIPTION
  50.  
  51. C<rpmtools> extend perl to manipulate hdlist file used by
  52. Linux-Mandrake distribution to compute dependancy file.
  53.  
  54. =head1 SEE ALSO
  55.  
  56. parsehdlist command is a simple hdlist parser that allow interactive mode
  57. use by DrakX upgrade algorithms.
  58.  
  59. =head1 COPYRIGHT
  60.  
  61. Copyright (C) 2000 MandrakeSoft <fpons@mandrakesoft.com>
  62.  
  63. This program is free software; you can redistribute it and/or modify
  64. it under the terms of the GNU General Public License as published by
  65. the Free Software Foundation; either version 2, or (at your option)
  66. any later version.
  67.  
  68. This program is distributed in the hope that it will be useful,
  69. but WITHOUT ANY WARRANTY; without even the implied warranty of
  70. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  71. GNU General Public License for more details.
  72.  
  73. You should have received a copy of the GNU General Public License
  74. along with this program; if not, write to the Free Software
  75. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  76.  
  77. =cut
  78.  
  79. #- build an empty params struct that can be used to compute dependancies.
  80. sub new {
  81.     my ($class, @tags) = @_;
  82.     my %tags; @tags{@_} = ();
  83.     bless {
  84.        flags         => [ qw(name version release size arch group requires provides),
  85.                   grep { exists $tags{$_} } qw(sense files obsoletes conflicts conffiles) ],
  86.        info          => {},
  87.        depslist      => [],
  88.        provides      => {},
  89.       }, $class;
  90. }
  91.  
  92. #- read one or more hdlist files, use packdrake for decompression.
  93. sub read_hdlists {
  94.     my ($params, @hdlists) = @_;
  95.     my @names;
  96.  
  97.     local (*I, *O); pipe I, O;
  98.     if (my $pid = fork()) {
  99.     close O;
  100.  
  101.     push @names, rpmtools::_parse_(fileno *I, $params->{flags}, $params->{info}, $params->{provides});
  102.  
  103.     close I;
  104.     waitpid $pid, 0;
  105.     } else {
  106.     close I;
  107.     open STDOUT, ">&O" or die "unable to redirect output";
  108.  
  109.     require packdrake;
  110.     packdrake::cat_archive(@hdlists);
  111.  
  112.     close O;
  113.     exit 0;
  114.     }
  115.     @names;
  116. }
  117.  
  118. #- build an hdlist from a list of files.
  119. sub build_hdlist {
  120.     my ($params, $noclean, $ratio, $dir, $hdlist, @rpms) = @_;
  121.     my %names;
  122.  
  123.     #- build a working directory which will hold rpm headers.
  124.     $dir ||= '.';
  125.     -d $dir or mkdir $dir, 0755 or die "cannot create directory $dir\n";
  126.  
  127.     foreach (@rpms) {
  128.     my ($key, $name) = /(([^\/]*)-[^-]*-[^-]*\.[^\/\.]*)\.rpm$/ or next;
  129.     system("rpm2header '$_' > '$dir/$key'") unless -e "$dir/$key";
  130.     $? == 0 or unlink("$dir/$key"), die "bad rpm $_\n";
  131.     -s "$dir/$key" or unlink("$dir/$key"), die "bad rpm $_\n";
  132.     push @{$names{$name} ||= []}, $key;
  133.     }
  134.  
  135.     #- compression ratio are not very high, sample for cooker
  136.     #- gives the following (main only and cache fed up):
  137.     #- ratio compression_time  size
  138.     #-   9       21.5 sec     8.10Mb   -> good for installation CD
  139.     #-   6       10.7 sec     8.15Mb
  140.     #-   5        9.5 sec     8.20Mb
  141.     #-   4        8.6 sec     8.30Mb   -> good for urpmi
  142.     #-   3        7.6 sec     8.60Mb
  143.     open B, "| packdrake -b${ratio}ds '$hdlist' '$dir' 400000";
  144.     foreach (@{$params->{depslist}}) {
  145.     if (my $keys = delete $names{$_->{name}}) {
  146.         print B "$_\n" foreach @$keys;
  147.     }
  148.     }
  149.     foreach (values %names) {
  150.     print B "$_\n" foreach @$_;
  151.     }
  152.     close B or die "packdrake failed\n";
  153.  
  154.     system("rm", "-rf", $dir) unless $dir eq '.' || $noclean;
  155. }
  156.  
  157. #- read one or more rpm files.
  158. sub read_rpms {
  159.     my ($params, @rpms) = @_;
  160.  
  161.     map { rpmtools::_parse_($_, $params->{flags}, $params->{info}, $params->{provides}) } @rpms;
  162. }
  163.  
  164. #- compute dependancies, result in stored in info values of params.
  165. #- operations are incremental, it is possible to read just one hdlist, compute
  166. #- dependancies and read another hdlist, and again.
  167. sub compute_depslist {
  168.     my ($params) = @_;
  169.  
  170.     #- avoid recomputing already present infos, take care not to modify
  171.     #- existing entries, as the array here is used instead of values of infos.
  172.     my @info = grep { ! exists $_->{id} } values %{$params->{info}};
  173.  
  174.     #- speed up the search by giving a provide from all packages.
  175.     #- and remove all dobles for each one !
  176.     foreach (@info) {
  177.     push @{$params->{provides}{$_->{name}} ||= []}, $_->{name};
  178.     }
  179.  
  180.     #- remove all dobles for each provides.
  181.     foreach (keys %{$params->{provides}}) {
  182.     $params->{provides}{$_} or next;
  183.     my %provides; @provides{@{$params->{provides}{$_}}} = ();
  184.     $params->{provides}{$_} = [ keys %provides ];
  185.     }
  186.  
  187.     #- take into account in which hdlist a package has been found.
  188.     #- this can be done by an incremental take into account generation
  189.     #- of depslist.ordered part corresponding to the hdlist.
  190.     #- compute closed requires, do not take into account choices.
  191.     foreach (@info) {
  192.     my %required_packages;
  193.     my @required_packages;
  194.     my %requires; @requires{@{$_->{requires} || []}} = ();
  195.     my @requires = keys %requires;
  196.  
  197.     while (my $req = shift @requires) {
  198.         $req eq 'basesystem' and next; #- never need to requires basesystem directly as always required! what a speed up!
  199.         ref $req or $req = $params->{provides}{$req} || ($req =~ /rpmlib\(/ ? [] :
  200.                                  [ ($req !~ /NOTFOUND_/ && "NOTFOUND_") . $req ]);
  201.         if (@$req > 1) {
  202.         #- this is a choice, no closure need to be done here.
  203.         exists $requires{$req} or push @required_packages, $req;
  204.         $requires{$req} = undef;
  205.         } else {
  206.         #- this could be nothing if the provides is a file not found.
  207.         #- and this has been fixed above.
  208.         foreach (@$req) {
  209.             my $info = $params->{info}{$_};
  210.             $required_packages{$_} = undef; $info or next;
  211.             if ($info->{deps} && !$info->{requires}) {
  212.             #- the package has been read from an ordered depslist file, and need
  213.             #- to rebuild its requires tags, so it can safely be used here.
  214.             my @rebuild_requires;
  215.             foreach (split ' ', $info->{deps}) {
  216.                 if (/\|/) {
  217.                 push @rebuild_requires, [ map { $params->{depslist}[$_]{name} || $_ } split /\|/, $_ ];
  218.                 } else {
  219.                 push @rebuild_requires, $params->{depslist}[$_]{name} || $_;
  220.                 }
  221.             }
  222.             $info->{requires} = \@rebuild_requires;
  223.             }
  224.             foreach (@{$info->{requires} || []}) {
  225.             unless (exists $requires{$_}) {
  226.                 $requires{$_} = undef;
  227.                 push @{ref $_ ? \@required_packages : \@requires}, $_;
  228.             }
  229.             }
  230.         }
  231.         }
  232.     }
  233.     unshift @required_packages, keys %required_packages;
  234.  
  235.     delete $_->{requires}; #- affecting it directly make perl crazy, oops for rpmtools. TODO
  236.     $_->{requires} = \@required_packages;
  237.     }
  238.  
  239.     #- sort packages, expand choices and closure again.
  240.     my %ordered;
  241.     foreach (@info) {
  242.     my %requires;
  243.     my @requires = ($_->{name});
  244.     while (my $dep = shift @requires) {
  245.         foreach (@{$params->{info}{$dep} && $params->{info}{$dep}{requires} || []}) {
  246.         if (ref $_) {
  247.             foreach (@$_) {
  248.             unless (exists $requires{$_}) {
  249.                 $requires{$_} = undef;
  250.                 push @requires, $_;
  251.             }
  252.             }
  253.         } else {
  254.             unless (exists $requires{$_}) {
  255.             $requires{$_} = undef;
  256.             push @requires, $_;
  257.             }
  258.         }
  259.         }
  260.     }
  261.  
  262.     if ($_->{name} eq 'basesystem') {
  263.         foreach (keys %requires) {
  264.         $ordered{$_} += 10001;
  265.         }
  266.     } else {
  267.         foreach (keys %requires) {
  268.         ++$ordered{$_};
  269.         }
  270.     }
  271.     }
  272.     #- setup, filesystem and basesystem should be at the beginning.
  273.     @ordered{qw(ldconfig readline termcap libtermcap2 bash sash glibc setup filesystem basesystem)} =
  274.       (100000, 90000, 80000, 70000, 60000, 50000, 40000, 30000, 20000, 10000);
  275.  
  276.     #- compute base flag, consists of packages which are required without
  277.     #- choices of basesystem and are ALWAYS installed. these packages can
  278.     #- safely be removed from requires of others packages.
  279.     foreach (@{$params->{info}{basesystem}{requires}}) {
  280.     ref $_ or $params->{info}{$_} and $params->{info}{$_}{base} = undef;
  281.     }
  282.     #- some package are always installed as base and can safely be marked as such.
  283.     foreach (qw(basesystem glibc)) {
  284.     $params->{info}{$_} and $params->{info}{$_}{base} = undef;
  285.     }
  286.  
  287.     #- give an id to each packages, start from number of package already
  288.     #- registered in depslist.
  289.     my $global_id = scalar @{$params->{depslist}};
  290.     foreach (sort { $ordered{$b->{name}} <=> $ordered{$a->{name}} || $a->{name} cmp $b->{name} } @info) {
  291.     $_->{id} = $global_id++;
  292.     }
  293.  
  294.     #- recompute requires to use packages id, drop any base packages or
  295.     #- reference of a package to itself.
  296.     foreach my $pkg (sort { $a->{id} <=> $b->{id} } @info) {
  297.     my ($id, $base, %requires_id, @requires_id);
  298.     foreach (@{$pkg->{requires}}) {
  299.         if (ref $_) {
  300.         #- all choices are grouped together at the end of requires,
  301.         #- this allow computation of dropable choices.
  302.         my ($to_drop, @choices_base_id, @choices_id);
  303.         foreach (@$_) {
  304.             my ($id, $base) = $params->{info}{$_} ? ($params->{info}{$_}{id}, exists $params->{info}{$_}{base}) : ($_, 0);
  305.             $base and push @choices_base_id, $id;
  306.             $base &&= ! exists $pkg->{base};
  307.             $to_drop ||= $id == $pkg->{id} || $requires_id{$id} || $base;
  308.             push @choices_id, $id;
  309.         }
  310.  
  311.         #- package can safely be dropped as it will be selected in requires directly.
  312.         $to_drop and next;
  313.  
  314.         #- if a base package is in a list, keep it instead of the choice.
  315.         if (@choices_base_id) {
  316.             ($id, $base) = ($choices_base_id[0], 1);
  317.         } else {
  318.             my $choices_key = join '|', @choices_id;
  319.             exists $requires_id{$choices_key} or push @requires_id, \@choices_id;
  320.             $requires_id{$choices_key} = undef;
  321.             next;
  322.         }
  323.         } else {
  324.         ($id, $base) = $params->{info}{$_} ? ($params->{info}{$_}{id}, exists $params->{info}{$_}{base}) : ($_, 0);
  325.         }
  326.  
  327.         #- select individual package.
  328.         $base &&= ! exists $pkg->{base};
  329.         $requires_id{$id} = $_;
  330.         $id == $pkg->{id} || $base or push @requires_id, $id;
  331.     }
  332.     #- cannot remove requires values as they are necessary for closure on incremental job.
  333.     $pkg->{deps} = join(' ', map { join '|', @{ref $_ ? $_ : [$_]} } @requires_id);
  334.     push @{$params->{depslist}}, $pkg;
  335.     }
  336.     1;
  337. }
  338.  
  339. #- read depslist.ordered file, as if it was computed internally.
  340. sub read_depslist {
  341.     my ($params, $FILE) = @_;
  342.     my $global_id = scalar @{$params->{depslist}};
  343.  
  344.     local $_;
  345.     while (<$FILE>) {
  346.     chomp; /^\s*#/ and next;
  347.     my ($name, $version, $release, $size, $deps) = /^(\S*)-([^-\s]+)-([^-\s]+)\s+(\d+)\s*(.*)/;
  348.  
  349.     #- store values here according to it.
  350.     push @{$params->{depslist}}, $params->{info}{$name} = {
  351.                                    name        => $name,
  352.                                    version     => $version,
  353.                                    release     => $release,
  354.                                    size        => $size,
  355.                                    deps        => $deps,
  356.                                    id          => $global_id++,
  357.                                   };
  358.     }
  359.  
  360.     #- compute base flag, consists of packages which are required without
  361.     #- choices of basesystem and are ALWAYS installed. these packages can
  362.     #- safely be removed from requires of others packages.
  363.     if ($params->{info}{basesystem} && ! exists $params->{info}{basesystem}{base}) {
  364.     my @requires_id;
  365.     foreach (split ' ', $params->{info}{basesystem}{deps}) {
  366.         /\|/ or push @requires_id, $_;
  367.     }
  368.     foreach ($params->{info}{basesystem}{id}, @requires_id) {
  369.         $params->{depslist}[$_] and $params->{depslist}[$_]{base} = undef;
  370.     }
  371.     }
  372.     1;
  373. }
  374.  
  375. #- relocate depslist array to use only the most recent packages,
  376. #- reorder info hashes too in the same manner.
  377. sub relocate_depslist {
  378.     my ($params) = @_;
  379.     my $relocated_entries = 0;
  380.  
  381.     foreach (@{$params->{depslist} || []}) {
  382.     if ($params->{info}{$_->{name}} != $_) {
  383.         #- at this point, it is sure there is a package that
  384.         #- is multiply defined and this should be fixed.
  385.         #- first correct info hash, then a second pass on depslist
  386.         #- is required to relocate its entries.
  387.         my $cmp_version = version_compare($_->{version}, $params->{info}{$_->{name}}{version});
  388.         if ($cmp_version > 0 ||
  389.         $cmp_version == 0 && version_compare($_->{release}, $params->{info}{$_->{name}}{release}) > 0) {
  390.         $params->{info}{$_->{name}} = $_;
  391.         ++$relocated_entries;
  392.         }
  393.     }
  394.     }
  395.  
  396.     if ($relocated_entries) {
  397.     for (0 .. scalar(@{$params->{depslist}}) - 1) {
  398.         my $pkg = $params->{depslist}[$_];
  399.         $pkg->{source} and next; #- hack to avoid losing local package.
  400.         $params->{depslist}[$_] = $params->{info}{$pkg->{name}};
  401.     }
  402.     }
  403.  
  404.     $relocated_entries;
  405. }
  406.  
  407. #- write depslist.ordered file according to info in params.
  408. sub write_depslist {
  409.     my ($params, $FILE, $min, $max) = @_;
  410.  
  411.     $min > 0 or $min = 0;
  412.     defined $max && $max < scalar(@{$params->{depslist} || []}) or $max = scalar(@{$params->{depslist} || []}) - 1;
  413.     $max >= $min or return;
  414.  
  415.     for ($min..$max) {
  416.     my $pkg = $params->{depslist}[$_];
  417.     printf $FILE "%s-%s-%s %s %s\n", $pkg->{name}, $pkg->{version}, $pkg->{release}, $pkg->{size}, $pkg->{deps};
  418.     }
  419.     1;
  420. }
  421.  
  422. #- fill params provides with files that can be used, it use the format for
  423. #- a provides file.
  424. sub read_provides_files {
  425.     my ($params, $FILE) = @_;
  426.  
  427.     local $_;
  428.     while (<$FILE>) {
  429.     chomp;
  430.     my ($k, @v) = split ':';
  431.     $k =~ /^\// and $params->{provides}{$k} ||= undef;
  432.     }
  433.     1;
  434. }
  435.  
  436. #- check if there has been a problem with reading hdlists or rpms
  437. #- to resolve provides on files.
  438. #- this is done by checking whether there exists a keys in provides
  439. #- hash where to value is null (and the key is a file).
  440. #- give the result as output.
  441. sub get_unresolved_provides_files {
  442.     my ($params) = @_;
  443.     my ($k, $v, @unresolved);
  444.  
  445.     while (($k, $v) = each %{$params->{provides}}) {
  446.     $k =~ /^\// && ! defined $v and push @unresolved, $k;
  447.     }
  448.     @unresolved;
  449. }
  450.  
  451. #- clean everything on provides but keep the files key entry on undef.
  452. #- this is necessary to try a second pass.
  453. #- support sense in flags.
  454. sub keep_only_cleaned_provides_files {
  455.     my ($params) = @_;
  456.     my @keeplist = map { s/\[\*\]//g; $_ } grep { /^\// } keys %{$params->{provides}};
  457.  
  458.     #- clean everything at this point, but keep file referenced.
  459.     $params->{info} = {};
  460.     $params->{depslist} = [];
  461.     $params->{provides} = {}; @{$params->{provides}}{@keeplist} = ();
  462. }
  463.  
  464. #- reset params to allow other entries.
  465. sub clean {
  466.     my ($params) = @_;
  467.  
  468.     $params->{info} = {};
  469.     $params->{depslist} = [];
  470.     $params->{provides} = {};
  471. }
  472.  
  473. #- read provides, first is key, after values.
  474. sub read_provides {
  475.     my ($params, $FILE) = @_;
  476.  
  477.     local $_;
  478.     while (<$FILE>) {
  479.     chomp;
  480.     my ($k, @v) = split ':';
  481.     $params->{provides}{$k} = @v > 0 ? \@v : undef;
  482.     }
  483. }
  484.  
  485. #- write provides, first is key, after values.
  486. sub write_provides {
  487.     my ($params, $FILE) = @_;
  488.     my ($k, $v);
  489.  
  490.     while (($k, $v) = each %{$params->{provides}}) {
  491.     printf $FILE "%s\n", join ':', $k, @{$v || []};
  492.     }
  493. }
  494.  
  495. #- read compss, look at DrakX for more info.
  496. sub read_compss {
  497.     my ($params, $FILE) = @_;
  498.     my $p;
  499.  
  500.     local $_;
  501.     while (<$FILE>) {
  502.     /^\s*$/ || /^#/ and next;
  503.     s/#.*//;
  504.  
  505.     if (/^(\S.*)/) {
  506.         $p = $1;
  507.     } else {
  508.         /(\S+)/;
  509.         $params->{info}{$1} and $params->{info}{$1}{group} = $p;
  510.     }
  511.     }
  512.     1;
  513. }
  514.  
  515. #- write compss.
  516. sub write_compss {
  517.     my ($params, $FILE) = @_;
  518.     my %p;
  519.  
  520.     foreach (values %{$params->{info}}) {
  521.     $_->{group} or next;
  522.     push @{$p{$_->{group}} ||= []}, $_->{name};
  523.     }
  524.     foreach (sort keys %p) {
  525.     print $FILE $_, "\n";
  526.     foreach (@{$p{$_}}) {
  527.         print $FILE "\t", $_, "\n";
  528.     }
  529.     print $FILE "\n";
  530.     }
  531.     1;
  532. }
  533.  
  534. #- compare a version string, make sure no deadlock can occur.
  535. #- try to return always a numerical value.
  536. sub version_compare {
  537.     my ($a, $b) = @_;
  538.     local $_;
  539.  
  540.     while ($a || $b) {
  541.     my ($sb, $sa) =  map { $1 if $a =~ /^\W*\d/ ? s/^\W*0*(\d+)// : s/^\W*(\D*)// } ($b, $a);
  542.     $_ = length($sa) <=> length($sb) || $sa cmp $sb and return $_ || 0;
  543.     $sa eq '' && $sb eq '' and return $a cmp $b || 0;
  544.     }
  545.     0;
  546. }
  547.  
  548. #- compability function which should be removed soon, do not use anymore and replace code.
  549. sub get_packages_installed {
  550.     my ($prefix, $packages, $names, $flags) = @_; $flags ||= [ qw(name version release)];
  551.     my $db = db_open($prefix);
  552.     my $count = db_traverse_tag($db, "name", $names, $flags, sub { my ($p) = @_; push @$packages, $p; });
  553.     db_close($db);
  554.     $count;
  555. }
  556. sub get_all_packages_installed {
  557.     my ($prefix, $packages, $flags) = @_; $flags ||= [ qw(name version release)];
  558.     my $db = db_open($prefix);
  559.     my $count = db_traverse($db, $flags, sub { my ($p) = @_; push @$packages, $p; });
  560.     db_close($db);
  561.     $count;
  562. }
  563. 1;
  564.